%%% The contents of this file are subject to the Erlang Public License,
%%% Version 1.0, (the "License"); you may not use this file except in
%%% compliance with the License. You may obtain a copy of the License at
%%% http://www.erlang.org/license/EPL1_0.txt
%%%
%%% Software distributed under the License is distributed on an "AS IS"
%%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
%%% the License for the specific language governing rights and limitations
%%% under the License.
%%%
%%% The Original Code is erlsoap-0.2
%%%
%%% The Initial Developer of the Original Code is Ericsson
%%% Telecommunicatie BV. All Rights Reserved.
%%%
%%%----------------------------------------------------------------------
%%% File			: mod_soap.erl
%%% Author			: Anton Fedorov <datacompboy@call2ru.com>
%%% Original Author : Erik Reitsma <Erik.Reitsma@etm.ericsson.se>
%%% Description 	: Module for httpd that handles SOAP calls
%%%
%%% Created : by Erik Reitsma <elnerei@tina29.etm.ericsson.se>
%%% Updated : 18 sep 2006 by Anton Fedorov <datacompboy@call2ru.com>
%%% Updated : 21 sep 2006 by Anton Fedorov <datacompboy@call2ru.com>
%%%----------------------------------------------------------------------

-module(mod_soap).
-vsn("0.4.1").

-include_lib("inets/src/httpd.hrl").

%% Starting and restarting the server.
-export([start/0,start/1,start_link/0,start_link/1,restart/0]).

%% Adding functions that handle SOAP calls.
-export([add_callback/3,add_callback/2]).

%% callback for http server
-export([do/1]).

%-compile(export_all).

-define(PRINT_MESSAGE(Text,Content),io:format("<~p:~p>(~p): "++Text,[?MODULE,?LINE,self()|Content])).

%% start() -> ok
%%
%% This function starts the httpd server with default config
%% file "8888.conf" and "soap-envelope.xsd" from current directory.
%%
start() ->
	ConfigFile = case application:get_env(erlsoap,inets_conf) of
		{ok,ConfFile} -> ConfFile;
		undefined -> "8888.conf"
	end,
	start(ConfigFile).
start_link() ->
	ConfigFile = case application:get_env(erlsoap,inets_conf) of
		{ok,ConfFile} -> ConfFile;
		undefined -> "8888.conf"
	end,
	start_link(ConfigFile).

%% start(ConfigFile) -> ok
%%
%% ConfigFile = string()
%% EnvelopeFile = string()
%%
%% This function starts the httpd server with the provided
%% config file and creates the necessary ets tables,
%% and parse soap-envelope xsd.
%% This is the start of the application.
%%
start(ConfigFile) ->
	monitor_server:start(),
	soap_registry_server:start(),
	create_callback_table(),
	httpd:start(ConfigFile).
start_link(ConfigFile) ->
	monitor_server:start_link(),
	soap_registry_server:start_link(),
	create_callback_table(),
	httpd:start(ConfigFile).

%% create_callback_table() -> ok
%%
%% This function creates the callback table for the SOAP
%% server. This function is called by start/0 and start/1,
%% but can be called on its own if httpd is started
%% elsewhere.
%%
create_callback_table() ->
	ets:new(soap_callback, [bag,public,named_table]).

%% restart() -> ok
%%
%% This function restarts the httpd server.
%%
restart() ->
	httpd:block(),
	httpd:restart(),
	httpd:unblock().

%% add_callback(URL,WSD,Fun) -> ok
%%
%% URL =		   string()
%% WSD =		   Filename of service descriptions
%% Fun =		   fun/2
%%
%% This function adds a fun that handles an all SOAP calls on
%% the provided URL. The URL should be an absolute path,
%% such as "/soap/rpcrouter".
%% All incoming requests are decoded with supplied WSD,
%% and fun called with decoded request, and full request
%% info.
%%	 fun(Info, Req) -> Ans
%% Fun should return {ok, [Res]}, where Res is response
%% structure as described by WSD.
%% To prepare headers from WSD run
%%	 erlsom:write_hrl(WSD,WSD++".hrl")
%% (prefix "p")
add_callback(URL,WSD,Fun) ->
	ok = soap_registry_server:add_xsd(URL,WSD),
	add_callback(URL,Fun).

add_callback(URL,Fun) ->
	ets:insert(soap_callback,{URL,Fun}).

%% do(Info)
%%
%% This function is called by the http server when a
%% http request comes in. It checks whether the request was
%% a POST. If not, the request is ignored. If it was,
%% handling is passed on to do_post/1.
%%
do(Info) ->
	Result =
	case Info#mod.method of
		"POST" ->
			case (catch do_post(Info)) of
				{'EXIT',Reason} ->
					?PRINT_MESSAGE("Error POST, reason = ~p~n",[Reason]),
					{proceed,Info#mod.data};
				GoodResult ->
					GoodResult
			end;
		"GET" ->
			{proceed,Info#mod.data};
		_Other ->
			{proceed,Info#mod.data}
	end,
	(catch monitor_result(Info,Result)),
	Result.

do_post(Info) ->
	case ets:lookup(soap_callback,Info#mod.request_uri) of
		{error,not_found}  ->
			{proceed,Info#mod.data};
		[] ->
			{proceed,Info#mod.data};
		[{_Url, Fun}] ->
			do_post_fun(Info, Fun)
	end.

do_post_fun(Info, Fun) ->
	case soap_registry_server:get_xsd(Info#mod.request_uri) of
		{error,not_found} ->
			do_post_fun2(Info,Fun);
		{ok, Model} ->
			do_soap(Info, {Model, Fun})
	end.

do_post_fun2(Info, Fun) ->
	case soap_registry_server:get_xsd("http://"++Info#mod.absolute_uri) of
		{error,not_found} ->
			{proceed,Info#mod.data};
		{ok, Model} ->
			do_soap(Info, {Model, Fun})
	end.

do_soap(Info, ModelFun) ->
	case Info#mod.entity_body of
		undefined ->
			{proceed,Info#mod.data};
		Line ->
			do_soap_with_body(Info,Line,ModelFun)
	end.

do_soap_with_body(Info,Line,{Model,Fun}) ->
	case lists:keysearch("content-type",1,Info#mod.parsed_header) of
		{value,{"content-type",Type}} ->
			case parse_content_type(Type) of
				{"text/xml",_} ->
					case (catch erlsom:parse(Line,Model)) of
						{'EXIT',Reason} ->
							?PRINT_MESSAGE("Could not parse, reason = ~p~n",[Reason]),
							{proceed,Info#mod.data};
						{ok,Parsed} ->
						do_soap_xml(Info, Parsed, {Model,Fun})
					end;
				{"multipart/related",ContentTypeParams} ->
					case lists:keysearch("boundary",1,ContentTypeParams) of
						{value,{"boundary",Boundary}} ->
							{{_StartPartHeader,StartPartBody},AttachedParts} =
								parse_parts(Boundary,ContentTypeParams,Line),
							case  (catch erlsom:parse(StartPartBody,Model)) of
								{'EXIT',Reason} ->
									?PRINT_MESSAGE("Could not parse, reason = ~p~n",[Reason]),
									{proceed,Info#mod.data};
								{ok,Parsed} ->
									do_soap_xml(Info#mod{data=[{attachments,AttachedParts}|Info#mod.data]}, Parsed, {Model,Fun})
							end;
						_ ->
							?PRINT_MESSAGE("No boundary in~n~p~n, info was ~n~p~n",[ContentTypeParams, Info]),
							{proceed,Info#mod.data}
					end;
				Other ->
					?PRINT_MESSAGE("Unsupported content type: ~p~n",[Other]),
					{proceed,Info#mod.data}
			end;
		_ ->
			?PRINT_MESSAGE("No content type~n",[]),
			{proceed,Info#mod.data}
	end.

do_soap_xml(Info, Parsed, ModelFun) ->
	case Parsed of
		{'soap:Envelope',_AnyArgs,_Header, {'soap:Body', _AnyArgs, Body}} ->
			do_soap_body(Info, Body, ModelFun);
		_Other ->
			{proceed,Info#mod.data}
	end.

do_soap_body(Info,[],_ModelFun) ->
	?PRINT_MESSAGE("No methods~n",[]),
	{proceed,Info#mod.data};
do_soap_body(Info,Requests,ModelFun) ->
	%% Call fun for current operation
	do_soap_body(Info,Requests,ModelFun,[]).

do_soap_body(Info,[],{Model,_Fun},Results) ->
	% Envelope results:
	Envelope =	{'soap:Envelope',undefined,undefined,{'soap:Body',undefined,lists:reverse(Results)}},
	case (catch erlsom:write(Envelope,Model)) of
		{ok, XML} -> make_reply(Info,XML);
		Other -> make_error(Info,.io_lib:format("Error=~p",[Other]))
	end;

do_soap_body(Info,[Request|Rest],{Model,Fun},Results) ->
	case (catch Fun(Info,Request)) of
		{ok,Res} ->
			do_soap_body(Info,Rest,{Model,Fun},[Res|Results]);
		Other ->
			%% This is an error case!
			%% TODO: Fault handling
			make_error(Info,.io_lib:format("Error=~p",[Other]))
	end.

make_reply(Info,String) ->
	Content = "<?xml version=\"1.0\" encoding=\"utf-8\"?>"++String,
	{break,[{response,{response,
			   [{code,200},
			{content_length,integer_to_list(length(Content))},
			{content_type,"text/xml; charset=UTF8"}],
			   Content
			  }
		}|
		Info#mod.data]}.

%% make_error(Info,Data) ->
%%
%% This functions makes a fault response. This is preliminary code,
%% and should be made properly...
%%
make_error(Info,String) ->
	?PRINT_MESSAGE("Error is ~s~n",[String]),
	Content = "<?xml version=\"1.0\" encoding=\"utf-8\"?>"++String,
	{break,[{response,
		 {response,
		  [{code,500},
		   {content_length,integer_to_list(length(Content))},
		   {content_type,"text/xml; charset=UTF8"}],
		  Content
		 }
		}|Info#mod.data]}.

parse_content_type(ContentType) ->
	{BasicType,Rest} = get_until(ContentType,";"),
	Params =
	get_header_params(Rest),
	{BasicType,Params}.

parse_parts(Boundary,ContentTypeParams,Body) ->
	case regexp:split(Body,"[\n\r]*.*"++Boundary++".*[\r\n]*") of
	{ok,PostElementsPlus} ->
		PostElements=remove_all([],PostElementsPlus),
		ParsedElements =
		lists:map(
		  fun(PE) ->
			  {PEHeader,PEBody} = header_lines(PE),
			  {isolate_args(PEHeader),
			   PEBody}
		  end,
		  PostElements),
		case lists:keysearch("start",1,ContentTypeParams) of
		{value,{"start",StartElementId}} ->
			[StartElement] =
			get_by_content_id(StartElementId,
					  ParsedElements),
			{StartElement,lists:delete(StartElement,ParsedElements)};
		_ ->
			?PRINT_MESSAGE("No start part in ~p, using the first~n",[ContentTypeParams]),
			{hd(ParsedElements),tl(ParsedElements)}
		end;
	_ ->
		?PRINT_MESSAGE("No boundary ~s in ~n~s~n",[Boundary,Body]),
		{[],[]}
	end.

get_by_content_id(ContentID,Elements) ->
	lists:filter(
	  fun({PEHeader,_PEBody}) ->
		  lists:member({"content-id",ContentID},PEHeader);
	 (_) ->
		  false
	  end,
	  Elements).

isolate_args(Fields) ->
	lists:map(fun isolate_arg/1, Fields).

isolate_arg(Str) -> isolate_arg(Str, []).

isolate_arg([$:,$ |T], L) -> {httpd_util:to_lower(lists:reverse(L)), T};
isolate_arg([H|T], L)	  -> isolate_arg(T, [H|L]).

get_header_params(String) ->
	get_header_params(String,[]).

get_header_params([],Res) ->
	lists:reverse(Res);
get_header_params([$ |More],Res) ->
	get_header_params(More,Res);
get_header_params([$\t|More],Res) ->
	get_header_params(More,Res);
get_header_params([$\r|More],Res) ->
	get_header_params(More,Res);
get_header_params([$\n|More],Res) ->
	get_header_params(More,Res);
get_header_params([$\;|More],Res) ->
	get_header_params(More,Res);
get_header_params(String,Res) ->
	case get_until(String,"=") of
	{Name,[]} ->
		lists:reverse([{Name,[]}|Res]);
	{Name,Rest} ->
		{Param,MoreRest} =
		get_string(Rest),
		get_header_params(MoreRest,[{Name,Param}|Res])
	end.

get_string([$"|More]) ->
	get_quoted_string(More);
get_string(String) ->
	get_unquoted_string(String).

get_unquoted_string(String) ->
	get_unquoted_string(String,[]).


get_unquoted_string([$\\,$ |More],Res) ->
	get_unquoted_string(More,[$ |Res]);
get_unquoted_string([$ |More],Res) ->
	{lists:reverse(Res),More};
get_unquoted_string([],Res) ->
	{lists:reverse(Res),[]};
get_unquoted_string([H|T],Res) ->
	get_unquoted_string(T,[H|Res]).

get_quoted_string(String) ->
	get_quoted_string(String,[]).

get_quoted_string([$\\,$"|More],Res) ->
	get_unquoted_string(More,[$ |Res]);
get_quoted_string([$"|More],Res) ->
	{lists:reverse(Res),More};
get_quoted_string([],Res) ->
	{lists:reverse(Res),[]};
get_quoted_string([H|T],Res) ->
	get_quoted_string(T,[H|Res]).


get_until(List,Element) ->
	get_until(List,Element,[]).

get_until([],_,Res) ->
	{lists:reverse(Res),[]};
get_until(L,H,Res) ->
	case lists:prefix(H,L) of
	true ->
		{lists:reverse(Res),lists:nthtail(length(H),L)};
	false ->
		get_until(tl(L),H,[hd(L)|Res])
	end.

header_lines(String) ->
	{yes,Header,Rest} =
	scan_header(String,[]),
	{ok,HeaderLines} =
	regexp:split(Header,"\\r?\\n"),
	{HeaderLines,Rest}.

scan_header([$\r,$\n,$\t|T],L) -> scan_header(T,[$ |L]);
scan_header([$\n,$\t|T],L) -> scan_header(T,[$ |L]);
scan_header([$\n,$ |T],L) -> scan_header(T,[$ |L]);
scan_header([$\r,$\n|T],L) -> scan_header([$\n|T],L);
scan_header([$\n,$\r|T],L) -> scan_header([$\n|T],L);
scan_header([$\n|T], [$\n|L]) -> {yes, lists:reverse(L), T};
scan_header([$\n|T], [$\r,$\n,$\r|L]) -> {yes, lists:reverse(L), T};
scan_header([$\n|T], [$\r,$\n|L]) -> {yes, lists:reverse(L), T};
scan_header([H|T],	L)				  -> scan_header(T, [H|L]);
scan_header([], L)					  -> {no, L}.

remove_all(Element,List) ->
	case lists:delete(Element,List) of
	List ->
		List;
	Less ->
		remove_all(Element,Less)
	end.

monitor_result(Info,{break,Result}) ->
	ReqHeaders =
	[pformat(Tag)++": "++pformat(Value)++"\r\n"||{Tag,Value}<-Info#mod.parsed_header],
	{ParsedRespHeaders,RespContent} =
	case lists:keysearch(response,1,Result) of
		{value,{response,
			{response,
			 RHeaders,
			 RContent}
		   }} ->
		{RHeaders,RContent};
		_ ->
		{"",""}
	end,
	RespHeaders =
	[pformat(Tag)++": "++pformat(Value)++"\r\n"||{Tag,Value}<-ParsedRespHeaders],
	Req=lists:flatten(ReqHeaders++"\r\n"++Info#mod.entity_body),
	Resp=lists:flatten(RespHeaders++"\r\n"++RespContent),
	monitor_server:send_data(make_long(length(Req))++
				 make_long(length(Resp))++
				 Req++Resp);
monitor_result(_Info,_OtherResult) ->
	ok.

make_long(Long) ->
	[Long band 255,
	 (Long bsr 8) band 255,
	 (Long bsr 16) band 255,
	 (Long bsr 24) band 255].

pformat(I) when integer(I) ->
	integer_to_list(I);
pformat(S) when list(S) ->
	S;
pformat(A) when atom(A) ->
	atom_to_list(A);
pformat(Other) ->
	lists:flatten(io_lib:format("~w",[Other])).
